home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / tforth21.lha / tile-forth-2.1 / lib / multi-tasking.f83 < prev    next >
Text File  |  1991-09-14  |  10KB  |  324 lines
  1. \
  2. \  MULTI-TASKING DEFINITIONS
  3. \
  4. \  Copyright (C) 1988-1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 30 June 1988
  15. \
  16. \  Last updated on: 4 September 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, enumerates, structures, blocks, queues
  20. \
  21. \  Description:
  22. \       Allows definition of tasks, condition queues, semaphores, channels,
  23. \       and rendezvous. Follows the basic models of concurrent programming
  24. \       primitives. 
  25. \
  26. \  Copying:
  27. \       This program is free software; you can redistribute it and\or modify
  28. \       it under the terms of the GNU General Public License as published by
  29. \       the Free Software Foundation; either version 1, or (at your option)
  30. \       any later version.
  31. \
  32. \       This program is distributed in the hope that it will be useful,
  33. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  34. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  35. \       GNU General Public License for more details.
  36. \
  37. \       You should have received a copy of the GNU General Public License
  38. \       along with this program; see the file COPYING.  If not, write to
  39. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  40.  
  41. .( Loading Multi-tasking definitions...) cr
  42.  
  43. #include enumerates.f83
  44. #include structures.f83
  45. #include blocks.f83
  46. #include queues.f83
  47.  
  48. blocks queues structures multi-tasking definitions
  49.  
  50. ( Task structure and status codes)
  51.  
  52. struct.type TASK-HEADER ( -- )
  53.   struct QUEUE +queue ( task -- addr) private
  54.   enum +status ( task -- addr) private
  55.   ptr  +sp ( task -- addr) private
  56.   ptr  +s0 ( task -- addr) private
  57.   ptr  +ip ( task -- addr) private
  58.   ptr  +rp ( task -- addr) private
  59.   ptr  +r0 ( task -- addr) private
  60.   ptr  +fp ( task -- addr) private
  61.   ptr  +ep ( task -- addr) private
  62. struct.end
  63.  
  64. enumerates
  65.  
  66. enum.type TASK-STATUS-CODES ( -- )
  67.   enum TERMINATED ( -- enum)        ( Terminated status code)
  68.   enum READY ( -- enum)            ( Ready for "schedule")
  69.   enum RUNNING ( -- enum)        ( Scheduled and running)
  70.   enum IOWAITING ( -- enum)        ( Waiting for in- or output)
  71.   enum WAITING ( -- enum)        ( Generic waiting)
  72.   enum DELAYED ( -- enum)        ( In delay function call)
  73. enum.end
  74.   
  75. multi-tasking
  76.  
  77. ( Task inquiry and manipulation functions)
  78.  
  79. : .task ( task -- )
  80.   dup foreground @ =            ( Check for foreground task)
  81.   if ." foreground#" else ." task#" then
  82.   dup . cr                ( Print task fields)
  83.   ." queue: " dup +queue .queue cr    ( The task queue pointers)
  84.   ." status: "dup +status @ . cr    ( The task status field)
  85.   ." sp: " dup +sp @ . cr        ( The task stack pointer)
  86.   ." s0: " dup +s0 @ . cr        ( The task stack bottom pointer)
  87.   ." ip: " dup +ip @ . cr        ( The task instruction pointer)
  88.   ." rp: " dup +rp @ . cr        ( The task return stack pointer)
  89.   ." r0: " dup +r0 @ . cr        ( The task return stack bottom pointer)
  90.   ." fp: " dup +fp @ . cr        ( The task argument frame pointer)
  91.   ." ep: " +ep @ .            ( The task exception frame pointer)
  92. ;
  93.  
  94. : deactivate ( queue task -- ) 
  95.   WAITING over +status !        ( Mark as waiting)
  96.   running @ succ >r            ( Access the next runnable task)
  97.   dup dequeue                ( Remove this task from the queue)
  98.   swap enqueue                ( And insert into queue of waiting)
  99.   r> resume                ( The next task)
  100. ;                    
  101.  
  102. : activate ( task -- ) 
  103.   RUNNING over +status !        ( Restore running state)
  104.   running @ succ enqueue        ( And insert it after the current task)
  105.   detach                 ( And restart it)
  106. ;
  107.  
  108. : delay ( n -- )
  109.   DELAYED running @ +status !        ( Indicate that the task is delayed)
  110.   0 do detach loop             ( Delay a task a number of switches)
  111.   RUNNING running @ +status !         ( Restore running state)
  112. ;
  113.  
  114. : join ( task -- ) 
  115.   WAITING running @ +status !        ( Indicate that the task is waiting)
  116.   begin                    ( Wait for task to terminate)
  117.     dup +status @             ( Check status. While not zero)
  118.   while                    ( and thus not terminate)
  119.     detach                ( Switch tasks)
  120.   repeat drop                ( Drop task parameter)
  121.   RUNNING running @ +status !         ( Restore running state)
  122. ;
  123.  
  124. : who ( -- ) 
  125.   ." task#: " running @            ( Print header and list of tasks)
  126.   block[ ( task -- ) . ]; map-queue
  127. ;
  128.  
  129. ( Condition Queue Variables)
  130.  
  131. struct.type CONDITION ( -- )
  132.   struct QUEUE +waiting ( condition -- addr) private
  133. struct.init ( condition -- )
  134.   +waiting as QUEUE initiate        ( Initiate condition queue)
  135. struct.end
  136.  
  137. : await ( condition -- )
  138.   +waiting running @ deactivate     ( Deactivate the current task)
  139. ;
  140.  
  141. : cause ( condition -- )
  142.   +waiting dup ?empty-queue        ( Check for empty queue)
  143.   if drop                ( Drop and return)
  144.   else                    ( Else activate the first waiting)
  145.     +waiting succ dup dequeue activate    ( task in the condition queue)
  146.   then
  147. ;
  148.  
  149. ( Dijkstra's Semaphore definition)
  150.  
  151. struct.type SEMAPHORE ( n -- )
  152.   struct CONDITION +not.zero ( semaphore -- addr) private
  153.   long +count ( semaphore -- addr) private
  154. struct.init ( n semaphore -- )
  155.   dup +not.zero as CONDITION initiate    ( Initiate semaphore condition)
  156.   +count !                ( Initiate semaphore counter)
  157. struct.end
  158.  
  159. : mutex ( -- )
  160.   1 SEMAPHORE                 ( Mutual exclusion semaphore)
  161. ;
  162.  
  163. : signal ( semaphore -- ) 
  164.   dup +not.zero +waiting ?empty-queue    ( Check if the waiting queue is empty)
  165.   if 1 swap +count +!             ( Increment counter)
  166.   else
  167.     +not.zero cause            ( Cause not zero condition)
  168.   then
  169. ;
  170.  
  171. : ?wait ( semaphore -- bool) 
  172.   +count @ 0=                 ( Check if a wait will delay the task)
  173. ;
  174.  
  175. : wait ( semaphore -- ) 
  176.   dup ?wait                ( Does the task have to wait)
  177.   if +not.zero await            ( Await not zero counter)
  178.   else
  179.     -1 swap +count +!            ( Decrement the counter)
  180.   then
  181. ;
  182.  
  183. ( Extension of Hoare's Channels)
  184.  
  185. enum.type COMMUNICATION-MODES ( -- )
  186.   enum ONE-TO-ONE ( -- enum)        ( Task to task communication)
  187.   enum ONE-TO-MANY ( -- enum)        ( One task to several tasks)
  188.   enum MANY-TO-ONE ( -- enum)        ( Several task to one task)
  189. enum.end
  190.  
  191. struct.type CHAN ( mode -- )
  192.   long +data ( chan -- addr) private
  193.   long +mode ( chan -- addr) private
  194.   struct SEMAPHORE +sent ( chan -- addr) private
  195.   struct SEMAPHORE +received ( chan -- addr) private
  196. struct.init ( mode chan -- )
  197.   tuck +mode !                ( Set up channel mode)
  198.   0 over +sent as SEMAPHORE initiate    ( Initiate semaphore fields)
  199.   0 swap +received as SEMAPHORE initiate ( as synchronize semaphores)
  200. struct.end
  201.  
  202. : ?avail ( chan -- bool) 
  203.   dup +mode @ MANY-TO-ONE =        ( Check channel mode)
  204.   if +received ?wait not        ( Check if receiver is available)
  205.   else +sent ?wait not then         ( Check if sender is available)
  206. ;
  207.  
  208. : send ( data chan -- ) 
  209.   dup +mode @ MANY-TO-ONE =        ( Check mode first)
  210.   if dup +received wait            ( Wait for a receiver)
  211.     tuck +data !            ( Assign data field)
  212.     +sent signal            ( And signal the receiver)
  213.   else
  214.     tuck +data !             ( Assign data field of channel)
  215.     dup +sent signal             ( Signal that data is available)
  216.     +received wait             ( And wait for receiver to fetch)
  217.   then
  218. ;
  219.  
  220. : receive ( chan -- data)  
  221.   dup +mode @ MANY-TO-ONE =        ( Check mode first)
  222.   if dup +received signal        ( Signal a receiver is ready)
  223.     dup +sent wait            ( Wait for sender)
  224.     +data @                ( Fetch sent data from channel)
  225.   else
  226.     dup +sent wait             ( Wait for sender to send data)
  227.     dup +data @             ( Fetch data from channel)
  228.     swap +received signal        ( And acknowledge to sender)
  229.   then
  230. ;
  231.      
  232. ( Message passing; rendezvous)
  233.  
  234. struct.type RENDEZVOUS ( -- )
  235.   struct CHAN +arg ( rendezvous -- addr) private
  236.   struct CHAN +res ( rendezvous -- addr) private
  237. struct.init ( rendezvous -- )
  238.   ONE-TO-ONE over +arg as CHAN initiate    ( Initiate argument channel)
  239.   ONE-TO-ONE swap +res as CHAN initiate    ( Initiate result channel)
  240. struct.does ( arg rendezvous -- res)
  241.   tuck +arg send            ( Send the argument)
  242.   +res receive                ( and receive the result)
  243. struct.end
  244.  
  245. : accept ( -- rendezvous arg)
  246.   ' >body [compile] literal        ( Access the rendezvous structure)
  247.   ?compile dup                ( Receive the argument to this task)
  248.   ?compile receive
  249. ; immediate
  250.  
  251. : accept.end ( rendezvous res -- )
  252.   ?compile swap                ( Send the result to the sender)
  253.   ?compile +res
  254.   ?compile send
  255. ; immediate
  256.  
  257. : ?awaiting ( -- bool)
  258.   ' >body [compile] literal        ( Access the rendezvous structure)
  259.   ?compile ?avail
  260. ; immediate
  261.  
  262. ( High Level Task definition with user variables)
  263.  
  264. forward make-task ( task.type -- task)
  265.  
  266. struct.type task.type ( parameters returns -- )
  267.   long +users ( task.type -- addr) private
  268.   long +parameters ( task.type -- addr) private
  269.   long +returns ( task.type -- addr) private
  270.   ptr  +body ( task.type -- addr) private
  271. struct.init ( parameters returns task.type -- entry task.type users0)
  272.   dup >r +returns !             ( Assign given fields)
  273.   r@ +parameters !             ( And prepare for definition of)
  274.   last r> sizeof TASK-HEADER        ( user variable fields for tasks)
  275. struct.does ( task -- )
  276.   make-task dup schedule constant    ( Make a task, start it)
  277. struct.end                ( And give it a name)
  278.  
  279. : make-task ( task.type -- task)
  280.   dup >r +users @             ( Fetch task size parameters)
  281.   r@ +parameters @             ( And pointer to task body)
  282.   r@ +returns @             ( And create a task instance)
  283.   r> +body @ task
  284. ;
  285.  
  286. : new-task ( -- task)
  287.   [compile] as                ( Requires symbol after to be a task)
  288.   ?compile make-task             ( type. Makes a task instance and)
  289.   ?compile dup                ( schedules it. Return pointer to)
  290.   ?compile schedule
  291. ; immediate
  292.  
  293. : bytes ( users1 size -- users2)  
  294.   over user +                 ( Create a user variable and update)
  295. ;
  296.  
  297. : task.field ( size -- )
  298.   create ,                 ( Save size of user variable type)
  299. does> @ bytes                ( Fetch size and create field name)
  300. ; private
  301.  
  302. : struct ( -- )
  303.   [compile] sizeof bytes        ( Fetch size of structure and create)
  304. ;
  305.  
  306. 1 task.field byte ( -- )
  307. 2 task.field word ( -- )
  308. 4 task.field long ( -- )
  309. 4 task.field ptr ( -- )
  310. 4 task.field enum ( -- )
  311.  
  312. : task.body ( task.type users3 -- ) 
  313.   align sizeof TASK-HEADER - over +users ! ( Align and assign user area size)
  314.   here swap +body !              ( Assign pointer to task body code)
  315.   ]                     ( And start compiling)
  316. ;
  317.  
  318. : task.end ( entry -- )
  319.   restore                ( Remove local symbols for task type)
  320.   [compile] ;                ( Stop compiling)
  321. ; immediate compilation
  322.  
  323. forth only
  324.